home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 60.zip / BS1 part 60 / Kick Pascal v2.10 d2.adf / DEMO / Banner.p < prev    next >
Text File  |  1990-11-01  |  14KB  |  435 lines
  1. {                                                                       }
  2. { BANNER                                                                }
  3. { ------                                                                }
  4. {                                                                       }
  5. { Ein Programm zur Papier- und Farbbandverschwendung.                   }
  6. {                                                                       }
  7. { Mit diesem Programm kann man meterlange Spruchbänder drucken.         }
  8. { Die Parameter werden vom CLI übergeben. Syntax:                       }
  9. {                                                                       }
  10. {  Banner { -v|-h|-cN|-xN|-yN|-rZ|+FONTNAME } TEXT                      }
  11. {                                                                       }
  12. { Die verschiedenen Parameter haben dabei folgende Bedeutung:           }
  13. {                                                                       }
  14. { -v  : vertikale Ausgabe (die Schrift läuft von oben nach unten        }
  15. { -h  : horizontale Ausgabe (zeilenweise)                               }
  16. {       Standardeinstellung ist "h" bei Zeichensätzen bis 15 Punkten    }
  17. {       Höhe und "v" ab 16 Punkten Schrifthöhe.                         }
  18. { -cN : (Center) Der Text ist horizontal und auf "N" Spalten zentriert  }
  19. {       auszugeben.                                                     }
  20. { -xN : Jeder Punkt des Zeichensatzes soll bei der Ausgabe "N" Sternchen}
  21. {       breit ausgedruckt werden.                                       }
  22. { -yN : Jeder Punkt des Zeichensatzes soll "N" Sterne hoch ausgegeben   }
  23. {       werden.                                                         }
  24. {       Standardeinstellung:    -x1 -y1  bei horizontaler Shcrift       }
  25. {                               -x3 -y1  bei vertokaler Ausgabe         }
  26. { -rZ : links ist ein "Z" Spalten breiter Rand zu lassen. Der Rand kann }
  27. {       auch negativ sein: dann werden die ersten "-Z" Zeichen jeder    }
  28. {       Zeile weggelassen.                                              }
  29. { +FONTNAME : Der enstprechende Amiga-Systemzeichensatz wird verwendet. }
  30. {       Beispiel: +Ruby15  benutzt den "Ruby.font" mit 15 Punkten Höhe. }
  31. {       Standardeinstellung ist "+topaz9".                              }
  32. { TEXT: Der Text, der auszugeben ist. Bei horizontaler Ausgabe können   }
  33. {       dabei mehrere Zeilen durch "\" getrennt werden.                 }
  34. {                                                                       }
  35. { Beispiele:                                                            }
  36. {                                                                       }
  37. { Banner Hallo                                                          }
  38. {  Ergebnis:                                                            }
  39. {  **   **              ***       ***                                   }
  40. {  **   **               **        **                                   }
  41. {  **   **   *****       **        **       *****                       }
  42. {  *******       **      **        **      **   **                      }
  43. {  **   **    *****      **        **      **   **                      }
  44. {  **   **  **   **      **        **      **   **                      }
  45. {  **   **   **** **    ****      ****      *****                       }
  46. {                                                                       }
  47. { Banner -v -x8 -y5 Hallo                                               }
  48. {  Der normale Topaz9-Font wird so vergrößert, daß er bei senkrechter   }
  49. {  Textausgabe den ganzen Bildschirm ausfüllt.                          }
  50. {                                                                       }
  51. { Banner +ruby15 -c77 Du\mich\auch!                                     }
  52. {  In drei zentrierten Zeilen wird der Text "Du mich auch!" mit dem     }
  53. {  Ruby15-Zeichensatz ausgegeben.                                       }
  54. {                                                                       }
  55. { Banner +emerald20 -r-5 Horrido!                                       }
  56. {  Es wird der Emerald20-Font benutzt. Durch die Höhe 20 wird           }
  57. {  automatisch senkrecht geschrieben. Dabei werden ("negativer Rand")   }
  58. {  die ersten 5 Spalten weggelassen, da sie eh' nur Spaces enthalten.   }
  59. {                                                                       }
  60. { Übrigens erfolgt die Ausgabe normalerweise auf dem Bildschirm. Wenn   }
  61. { Sie das Banner drucken wollen, müssen Sie es mit "Banner >prt: ..."   }
  62. { zum Printer schicken.                                                 }
  63.  
  64.  
  65. Program banner(output);
  66.  
  67. { Written by Jens "Himpel" Gelhar Oct/Nov. 89 }
  68.  
  69. {$path "ram:i/", "pascal:include/" }
  70. {$incl "graphics/text.h", "graphics.lib", "libraries/diskfont.h" }
  71.  
  72. Label 99;
  73.  
  74. Const
  75.   Trenn = '\';
  76.  
  77. Type
  78.   CLocType = Array [0..255] of Record offset, breite:Word End;
  79.   SpaceType = Array[0..255] of integer;
  80.   strtype = String[200];
  81.  
  82. Var
  83.   fnt: p_TextFont;      { Zeiger auf Font-Struktur }
  84.   txat: TextAttr;       { Text-Attribut-Struktur für "OpenDiskFont" }
  85.   YSize: integer;       { Zeichensatzhöhe }
  86.   Fontname: string[50]; { Zeichensatzname }
  87.   i, j: integer;
  88.   Punktbreite, Punkthoehe: integer;   { "Vergrößerung" }
  89.   tx: string[300];                    { Puffer für ParameterString }
  90.   err, VertFlag, HorizFlag, CenterFlag: Boolean;
  91.   Ausgabe: strtype;
  92.   HiChar, LoChar: char;
  93.   CharData: Long;       { Bitplane-Adresse }
  94.   Offset, Width, Kern, Space: Array[Char] of integer;
  95.   Modulo, Rand: integer;
  96.   Zeilenlaeng: integer;
  97.   buf: String[257];     { Puffer für Ausgabe }
  98.  
  99.  
  100. Procedure InitVars;
  101.  { Nach "OpenDiskFont" diverse Variablen aufgrund von Feldern }
  102.  { der Font-Struktur initialisieren                           }
  103.  Var
  104.   clp: ^CLocType;
  105.   krp,spp: ^SpaceType;
  106.   i: integer;
  107.   c: Char;
  108.  Begin
  109.   LoChar := chr(fnt^.tf_LoChar);
  110.   HiChar := chr(fnt^.tf_HiChar);
  111.   Modulo := fnt^.tf_Modulo;
  112.   CharData := Long(fnt^.tf_CharData);
  113.   clp := fnt^.tf_CharLoc;
  114.   krp := fnt^.tf_CharKern;
  115.   spp := fnt^.tf_CharSpace;
  116.   For c:=chr(0) to chr(MaxByte) do   { Defaultwerte für Bereich }
  117.     Begin                            { außerhalb LoChar..HiChar }
  118.       Offset[c]:= 0;
  119.       Width[c] := 0;
  120.       Space[c] := fnt^.tf_xsize;
  121.       Kern[c]  := 0
  122.     End;
  123.   For c:=LoChar to HiChar Do { wegen schnelleren Zugriffs Daten }
  124.     Begin                    { aus der Font-Struktur in Arrays kopieren }
  125.       Offset[c] := clp^[ord(c)-ord(LoChar)].offset;
  126.       Width [c] := clp^[ord(c)-ord(LoChar)].breite;
  127.       If krp=Nil Then
  128.         Kern[c] := 0
  129.       Else
  130.         Kern[c] := krp^[ord(c)-ord(LoChar)];
  131.       If spp=Nil Then
  132.         Space[c] := fnt^.tf_XSize
  133.       Else
  134.         Space[c] := spp^[ord(c)-ord(LoChar)];
  135.     End;
  136.   YSize := fnt^.tf_YSize
  137.  End;
  138.  
  139.  
  140. Function Dot(ch: char; x,y: integer): Boolean;
  141.   { prüft, ob Punkt (x,y) im Zeichen "ch" des aktuellen Fonts }
  142.   { gesetzt ist.                                              }
  143.   Var
  144.     Adr: Long;
  145.     Schleif, Off: integer;
  146.   Begin
  147.     If x < kern[ch] Then
  148.       Dot:=false
  149.     Else
  150.       Begin
  151.         If x >= Width[ch]+kern[ch] Then
  152.           Dot:=false
  153.         Else
  154.           Begin
  155.             Off := offset[ch] - kern[ch] + x;
  156.             Adr := CharData + y * Modulo + Off div 8;
  157.             Dot := (Mem[Adr] and ($80 shr (Off mod 8))) <> 0
  158.           End;
  159.       End
  160.   End;
  161.  
  162.  
  163. Procedure Aus(k: integer);
  164.   { String "buf" mit Rand und ohne überflüssige }
  165.   { Leerzeichen am Ende "k"-mal ausgeben        }
  166.   Var i, j: integer;
  167.   Begin
  168.     If Rand<0 Then
  169.       For i:=1 to StrLen(buf)+Rand+1 do buf[i]:=buf[i-Rand];
  170.     i:=Length(buf);
  171.     While (i>1) and (buf[i]=' ') Do i:=pred(i);
  172.     If buf[i]=' ' Then buf[i]  :=chr(0)
  173.                   Else buf[i+1]:=chr(0);
  174.     For j:=1 to k Do
  175.       Begin
  176.         If break(1) Then      { Ctrl-C? Dann geordneter Ausstieg. }
  177.           Begin
  178.             writeln('^C');
  179.             Goto 99
  180.           End;
  181.         If Rand>0 Then write('': Rand);
  182.         writeln(buf)
  183.       End
  184.   End;
  185.  
  186. Procedure Horizontal(s: strtype);
  187.   { waagerechte Ausgabe }
  188.   Var x, y, i, j, i0, x1, y1: integer;
  189.       breite, Pos0, t: integer;
  190.       c: char;
  191.   Begin
  192.     i0 := 1;
  193.     While s[i0] >= ' ' Do
  194.      Begin
  195.       breite:=0;
  196.       i:=i0;
  197.       While (s[i]>=' ') and (s[i]<>Trenn) Do
  198.         Begin
  199.           breite := breite + Punktbreite*space[s[i]];
  200.           i := i+1
  201.         End;
  202.  
  203.       If breite > 256 Then
  204.         Begin
  205.           writeln('Maximum lenght of line is 256');
  206.           goto 99
  207.         End;
  208.  
  209.       If Centerflag Then Pos0 := (Zeilenlaeng-breite) div 2
  210.                     Else Pos0 := 0;
  211.       For y:=0 To YSize-1 Do
  212.         Begin
  213.           i:=i0;
  214.           t:=1;
  215.           For j:=1 To Pos0 Do
  216.             Begin
  217.               buf[t] := ' ';
  218.               t := t+1
  219.             End;
  220.           While (s[i] >= ' ') and (s[i] <> Trenn) Do
  221.             Begin
  222.               c := s[i];
  223.               If (c < LoChar) or (c > HiChar) Then c:=' ';
  224.               For x:=0 To space[c]-1 Do
  225.                 If Dot(c,x,y) Then
  226.                   For x1:=1 To Punktbreite Do
  227.                     Begin
  228.                       buf[t]:='*';
  229.                       t:=succ(t)
  230.                     End
  231.                  Else
  232.                   For x1:=1 To Punktbreite Do
  233.                     Begin
  234.                       buf[t]:=' ';
  235.                       t:=succ(t)
  236.                     End;
  237.               i:=i+1
  238.             End;
  239.           buf[t]:=chr(0);
  240.           Aus(PunktHoehe)
  241.         End;
  242.       i0 := i;
  243.       If s[i] = Trenn Then i0 := i0+1
  244.      End;
  245.   End;
  246.  
  247.  
  248. Procedure Vertikal(s: strtype);
  249.   Var x, y, i, t, x1, y1: integer;
  250.       c: char;
  251.   Begin
  252.     i:=1;
  253.     While s[i] >= ' ' Do
  254.       Begin
  255.         c := s[i];
  256.         If (c < LoChar) or (c > HiChar) Then c:=' ';
  257.         For x:=0 to Space[c]-1 Do
  258.           Begin
  259.             t:=1;
  260.             For y:=YSize-1 Downto 0 Do
  261.               If Dot(c,x,y) Then
  262.                 For y1:=1 To Punktbreite Do
  263.                   Begin buf[t]:='*'; t:=succ(t) End
  264.                Else
  265.                 For y1:=1 To Punktbreite Do
  266.                   Begin buf[t]:=' '; t:=succ(t) End;
  267.              buf[t]:=chr(0);
  268.              Aus(PunktHoehe)
  269.           End
  270.         i:=i+1
  271.       End;
  272.   End;
  273.  
  274.  
  275. Function Digit(ch: Char): integer;
  276.   { testen, ob Zeichen "ch" Ziffer ist, und Wert zurückgeben }
  277.   Begin
  278.     If ch in ['0'..'9'] Then
  279.       Digit := ord(ch)-ord('0')
  280.     Else
  281.       Digit := -1
  282.   End;
  283.  
  284.  
  285. Procedure Info;
  286.   { Info-Text ausbannern }
  287.   Begin
  288.     txat := TextAttr('topaz.font', 9, 0, 0);
  289.     fnt := OpenDiskFont(^txat);
  290.     If fnt=Nil Then
  291.       error('Font nicht gefunden!');
  292.     InitVars;
  293.     Punktbreite:=1;
  294.     Punkthoehe:=1;
  295.     Centerflag := true;
  296.     Zeilenlaeng:=77;
  297.     write(''\n\e'33m');
  298.     Horizontal('Banner');
  299.     write(''\e'31m'\n);
  300.     Horizontal('Written\by:\Jens\Gelhar\1989')
  301.   End;
  302.  
  303.  
  304. Begin
  305.   OpenLib(DiskFontBase, 'diskfont.library', 0);
  306.   OpenLib(GfxBase, 'graphics.library', 0);
  307.  
  308.   YSize := 9;
  309.   Fontname := 'topaz.font';     { Defaultfont und -höhe }
  310.   Punktbreite := 0;
  311.   Punkthoehe := 0;
  312.   Rand := 0;
  313.   tx := parameterstr;
  314.   tx[parameterlen+1] := chr(0);
  315.   i := 1;
  316.   VertFlag := false;
  317.   Horizflag := false;
  318.   Centerflag := false;
  319.   While tx[i]=' ' Do i:=succ(i);
  320.   err:= tx[i]<' ';
  321.   While ((tx[i]=' ') or (tx[i]='-') or (tx[i]='+')) and not err Do
  322.     { Optionen auswerten }
  323.     Begin
  324.       If tx[i]='+' Then
  325.         Begin
  326.           j:=1; i:=i+1;
  327.           While tx [i] >= 'A' Do
  328.             Begin
  329.               Fontname[j] := tx[i];
  330.               i := i+1;
  331.               j := j+1
  332.              End;
  333.            fontname[j] := chr(0);
  334.            If fontname='' Then err:=true;
  335.            fontname:=fontname + '.font';
  336.            YSize:=Digit(tx[i]);
  337.            If YSize<0 Then err:=true
  338.            Else
  339.              If Digit(tx[i+1]) >= 0 Then
  340.                Begin
  341.                  i := i+1;
  342.                  YSize := 10*YSize + digit(tx[i])
  343.                End;
  344.           If not(Vertflag or Horizflag) Then
  345.             Begin
  346.               Vertflag:= YSize>16;
  347.               Horizflag := not Vertflag
  348.             End;
  349.         End;
  350.       If tx[i]='-' Then
  351.         Begin
  352.           i:=i+1;
  353.           Case tx[i] Of
  354.           'v': VertFlag:=true;
  355.           'h': VertFlag:=false;
  356.           'x': Begin i:=i+1; PunktBreite:=Digit(tx[i]);
  357.                      err := Punktbreite<0
  358.                End;
  359.           'y': Begin i:=i+1; PunktHoehe:=Digit(tx[i]);
  360.                      err := Punkthoehe<0
  361.                End;
  362.           'r': Begin i := i+1;
  363.                      If tx[i]='-' Then
  364.                        Begin
  365.                          i:=i+1; j:=-1
  366.                        End
  367.                      Else j:=1;
  368.                      Rand:=Digit(tx[i]);
  369.                      If Rand<=0 Then err:=true
  370.                      Else
  371.                        While Digit(tx[i+1])>=0 Do
  372.                          Begin
  373.                            i:=i+1; Rand:=10*Rand+Digit(tx[i])
  374.                          End;
  375.                      Rand := j*Rand; { Vorzeichen }
  376.                End;
  377.           'c': Begin
  378.                  i := i+1;
  379.                  Zeilenlaeng := Digit(tx[i]);
  380.                  If Zeilenlaeng <= 0 Then err:=true
  381.                  Else
  382.                  While Digit(tx[i+1]) >= 0 Do
  383.                    Begin
  384.                      i:=i+1; Zeilenlaeng := 10*Zeilenlaeng + Digit(tx[i])
  385.                    End;
  386.                  Centerflag := true;
  387.                  Horizflag := true;
  388.                  Vertflag := false;
  389.                  If Zeilenlaeng > 256 Then
  390.                    Error('Maximum lenght of line is 256')
  391.                End;
  392.           '?': Info;
  393.           Otherwise
  394.             err:=true
  395.           End
  396.         End;
  397.       i := i+1
  398.     End;
  399.  
  400.   Ausgabe:=Copy(tx,i,Length(tx)-i+1);  { Rest ist auszugeben }
  401.  
  402.   If err Then
  403.     Error('Usage: Banner { -v|-h|-cN|-xN|-yN|-rZ|+FONTNAME } TEXT'\n' Info: Banner -?');
  404.  
  405.   If Punktbreite=0 Then             { Defaultwerte: }
  406.     If VertFlag Then Punktbreite := 3
  407.                 Else Punktbreite := 1;
  408.  
  409.   If Punkthoehe=0 Then Punkthoehe:= 1;
  410.  
  411.   txat := TextAttr(Fontname, YSize, 0, 0);
  412.   fnt := OpenDiskFont(^txat);       { Zeichensatz laden }
  413.   If fnt=Nil Then
  414.     error('Font nicht gefunden!');
  415.   InitVars;
  416.  
  417.   If Vertflag and (YSize*Punktbreite>256) Then
  418.     Begin
  419.       CloseFont(fnt);
  420.       Error('Maximum lenght of line is 256')
  421.     End;
  422.  
  423.   If VertFlag Then
  424.     Vertikal(Ausgabe)
  425.   Else
  426.     Horizontal(Ausgabe)
  427.  
  428. 99:
  429.   CloseFont(fnt);
  430.   CloseLib(GfxBase);
  431.   CloseLib(DiskFontBase)
  432. End.
  433.  
  434.  
  435.